perm filename BEAMS.F4[NEW,LCS]28 blob
sn#554910 filedate 1981-01-02 generic text, type T, neo UTF8
00100 C*** BEAMS, BMREAD ************
00200 SUBROUTINE BEAMS
00300 INTEGER UPDN
00400 COMMON R2,JAZ,CENTR,JBZ,RJQ(20),JQ(20) /STF/RSTFAC(8),RSTJ2
00500 1 /XRN/RN(1) /PTR/KWDS(1) /RNW/RNW /A2Z/LAA,LBB
00600 1 /RINP/R(10,85),POSNT(0/99) /RMOD/RMODE2,SET4,IBEAM,
00700 1 NOSET,STEM,STUP,NTC,PS2,RAM,JSTEM,IT,POS
00800 1 /FRMT/F78F(1),FA1(1),FA5(1) /ALF/INP(72),ML
00900 1 /LIMIT/LIMIT,ITEM,LL,IS,IX /DPY/ST(3900),RHY(100)
01000 1 /SCM/V(78),I,LCNT,STAFF,LIST(200),REND
01100 1 /SCX/JALPHA(7),ISTAR,JAL(22),X,U,JZ,IRHY,JD,KA,KB,IZ
01200 1 /SC/J,L,MK,ISKP,XMINUS,N,IEXP,LK,NNUM,JJ,JA,DBST,NFLG
01300 1 ,JXX,ISEMI,IQT,VX(50),IAMP,K,KN,M,MODE,IBLA
01400
01500 IF(RMODE.GE.500)RETURN
01600 C NO BEAMS WHEN USING SUBR. 'EXTRA' *********
01700 INVT=-1
01800 LS=IS
01900 C SAVE PTR TO RN ARRAY FOR SLUR FEATURE AT 614 (AND TREM. FEATURE)
02000 JNTC=NTC
02100 J=0
02200 A=-1.
02300 DO 1125 K=1,IZ
02400 RHY(K)=0
02500 C MUST BE ZEROED TO AVOID CONFUSION AT C.2212
02600 IF(R(1,K).GT.2)GO TO 1125
02700 C GET BACK RHYTH. INFO IN P9 OF NOTES (FOR JDIF, COMPOSITE BEAMS)
02800 B=R(3,K)
02900 IF(A.EQ.B)GO TO 1125
03000 C SKIP CHORD NOTES.
03100 A=B
03200 J=J+1
03300 RHY(K)=V(J)
03400 1125 CONTINUE
03500 125 IF(REND.NE.0)GO TO 25
03600 REND=3
03700 25 DO 1500 K=1,72
03800 IF(INP(K).EQ.LBB)GO TO 22
03900 C B=AUTOMATIC BEAMS.
04000 IF(INP(K).EQ.ISTAR)GO TO 15
04100 1500 IF(INP(K).EQ.ISEMI)GO TO 500
04200 15 INP(72)=ISTAR
04300 GO TO 500
04400 C ABOVE FOR 2ND LNE OF INPUT. IF LNS ENDS WITHOUT * OR ;, IT PUTS IN *
04500 22 REREAD F78F,A,RB,RC
04600 C TYPE '2B' OR '3B' ETC. FOR AUTOMATIC BEAMS. (2=DUPLE 3=TRIPLE)
04700 A=A/2.
04800 C '2'=1 '3'=1.5 '2B 3;' MEANS THERE'S A 3 NOTE PICK-UP.
04900 CS IF(STEM)STEM=0
05000 C STEM=10 OR 20 IF ALREADY SETUP IN NOTES
05100 N=0
05200 J=0
05300 INP(72)=ISTAR
05400
05500 GR=4./88.
05600 NN=0
05700 NX=0
05800 C NX IS REST COUNTER
05900 NZ=0
06000 NL=1
06100 NJ=0
06200 NR=1
06300 JV=0
06400 C JV IS VX COUNTER
06500 C=0
06600 B=A-.001
06700 IF(RB.EQ.0)GO TO 122
06800 J=RB
06900 C RB=NUM OF PICKUP ITEMS.*******(NTS AND RSTS - BUT NOT GRACE NTS.)*******
07000 B=-.001
07100 DO 222 K=1,J
07200 222 IF(V(K).NE.GR)B=B+ABS(V(K))
07300 C ABOVE FOUND VALUE OF PICKUPS
07400 122 X=ABS(V(NR))
07500 IF(X.NE.GR)GO TO 2122
07600 NN=NN+1
07700 GO TO 2022
07800 2122 C=C+X
07900 C ADD ON RHYTH VALUE -- IF NOT GRACE NOTES
08000 IF(V(NR).LT.0)N=N+1
08100 C FINDS RESTS AND GRACE NOTES (WE SKIP THEM)
08200 IF(C.GT.B)GO TO 822
08300 2022 IF(NR.EQ.IRHY)GO TO 422
08400 922 NR=NR+1
08500 CC IF(NOTAIL(V(NR-1)).LT.0)GO TO 322
08600 C NR=RIGHT SIDE OF BEAM, NL=LEFT
08700 GO TO 122
08800 822 IF(NR-NL-NN-N.GT.0)GO TO 322
08900 C IGNORE IF ONLY ONE NOTE FILLS UNIT
09000 722 IF(NR.EQ.IRHY)GO TO 422
09100 NN=0
09200 NJ=NJ+N
09300 NZ=NJ
09400 N=0
09500 NL=NR+1
09600 C PUSH AHEAD FOR NEXT BEAM
09700 622 B=B+A
09800 C UPDATE SPACE POINTER
09900 IF(C.GT.B)GO TO 622
10000 GO TO 922
10100
10200 C MAIN AUTO BEAM SECTION.
10300 322 DO 21 K=NL,NR-1
10400 C THIS LOOP FINDS FIRST NOTE OF BEAM.
10500 X=V(K)
10600 IF(X.LT.0)GO TO 21
10700 IF(X.EQ.GR)GO TO 21
10800 IF(NOTAIL(X).LT.0)GO TO 21
10900 C SKIP IF NOTE VAL. DOESN'T REQUIRE A TAIL
11000 COUNTER FOR VX ARRAY (WHERE WE PUT BEAM'S NOTE NUMS.)
11100 VX(JV+1)=K-NREST(K)
11200 C FUNCT. NREST TELLS HOW MANY RESTS TO SUBTRACT
11300 GO TO 221
11400 21 CONTINUE
11500 C IF WE GET HERE, NO BEAM NOTES FOUND.
11600 GO TO 722
11700 221 DO 321 JB=K,NR
11800 C THIS LOOP FINDS LAST NOTE OF BEAM.
11900 X=V(JB)
12000 IF(NOTAIL(X).LT.0)GO TO 522
12100 C JUMP OUT WHEN NON-BEAM DURATION IS FOUND
12200 IF(X.LT.0)GO TO 321
12300 IF(X.EQ.GR)GO TO 321
12400 JA=JB
12500 321 CONTINUE
12600 522 IF(JA.EQ.K)GO TO 523
12700 JV=JV+2
12800 VX(JV)=JA-NREST(JA)
12900 C NREST SUBTRACTS ALL INTERVENING RESTS
13000 523 IF(JA.GE.NR-1)GO TO 722
13100 C NO ROOM FOR MORE BEAMS
13200 NL=JB
13300 C START FROM WHERE WE LEFT OFF
13400 GO TO 322
13500
13600 C NEXT FOR BEAMED GRACE NOTES
13700 422 N=0
13800 J=1
13900 1122 X=V(J)
14000 IF(X.LT.0)N=N+1
14100 NR=0
14200 IF(X.NE.GR)GO TO 1022
14300 NL=J
14400 DO 1222 K=J,IRHY
14500 X=V(K)
14600 IF(X.LT.0.OR.X.NE.GR)GO TO 1322
14700 C STOPS GRACE NOTE BEAM AT REST OR NON-GRACE
14800 1222 NR=K
14900 1322 IF(NR-NL.LE.0)GO TO 1022
15000 CALL BAUTO(JV,NL,NR,N)
15100 C UPDATE VX COUNTER
15200 NL=NL+1
15300 J=NR
15400 1022 J=J+1
15500 IF(J.LE.IRHY)GO TO 1122
15600
15700 1422 IF(JV.EQ.0)RETURN
15800 C NO BEAMS - SO GO BACK.
15900 DO 2822 K=JV+1,50
16000 C USES ONLY 68 SLOTS IN 'V'
16100 2822 VX(K)=0
16200 CC END
16300
16400 J=0
16500 GO TO 511
16600
16700 C ******* 1ST MAIN LOOP *********
16800 500 REREAD F78F,VX
16900 J=0
17000 511 J=J+1
17100 N=VX(J)
17200 JMP=1
17300 JDIF=0
17400 505 L=0
17500 K=0
17600 C=0
17700 POS=-10.
17800 RN(8+IS)=0
17900 RN(9+IS)=0
18000 IT=0
18100 UPDN=0
18200 CS IF(JSTEM.LT.*****0)GO TO 503
18300 CS IF(STEM.EQ.0)GO TO 503
18400 C UPDN=2=STEMS DOWN, (SLUR DIP UP) =1, OPPOSITE.
18500 104 JA=J+1
18600 B=VX(JA)
18700 C THE 2ND NOTE (-=DIP DOWN ALWAYS; +100=UP ALWAYS, ORD.=AUTOMATIC)
18800 IF(B.LT.100)GO TO 512
18900 C**** UPDN=2
19000 B=B-100
19100 IF(B.GT.100)B=100-B
19200 C TYPE -NUM OR 200+NUM FOR DIP DOWN.
19300 VX(JA)=B
19400 UPDN=B
19500 C***512 IF(B.LT.0)UPDN=1
19600 512 RN(9+IS)=0
19700 BRK=AMOD(VX(J),1.)*10.
19800 IF(BRK.NE.0)RN(9+IS)=BRK+.0001
19900 C ADDS NUM TO BRACK. OR BEAM. ADD DESIRED .NUM TO 1ST NUM.(1.3=3)
20000 CCC IF(BRK.EQ.0)GO TO 503
20100 CCC RN(9+IS)=BRK+.0001
20200 CCC GO TO 5030
20300 503 IF(N.LE.0.OR.N.GE.JNTC)TYPE 5031,N
20400 5031 FORMAT(' ****WRONG BEAM NUMBER? ',I3)
20500 C 503 IF(N.GT.0)GO TO 5031
20600 C IT=-1
20700 C CALL SLEND
20800 CC -1= SLUR INTO 1ST NOTE.
20900 CC SETS POS OF LFT SIDE (-10+9, THEN +2)
21000 C GO TO 5060
21100 C 5031 IF(N.LE.JNTC)GO TO 5030
21200 CC JNTC=NUM OF REAL NTS+1
21300 C CALL SLEND
21400 CC SLEND CHECKS ON END POINTS OF THIS STAFF (FOR SLURS)
21500 C GO TO 504
21600 5030 L=L+1
21700 502 K=K+1
21800 IF(R(1,K).NE.1.)GO TO 502
21900 C IS IT A NOTE?
22000 P=R(3,K)
22100 IF(P.EQ.POS)GO TO 502
22200 C SKIPS DBLSTPS
22300 POS=P
22400 IF(L.LT.N)GO TO 506
22500 IF(C.NE.0)GO TO 506
22600 IF(R(10,K).EQ.0)C=19.-R(5,K)
22700 C GET STEM DIR. OF 1ST NOTE ON MAIN STAFF
22800 506 IF(L.LT.N)GO TO 5030
22900 5060 IF(JMP.LT.0)GO TO 504
23000 C JMP=-1 MEANS END NOTE OF GROUP
23100 J=J+1
23200 NN=VX(J)
23300 C IF 2ND NUM IS .LE. 1ST , THEN 2-NOTE SLUR. (-1 GOES TO 1)
23400 IF(NN.EQ.0)NN=N+1
23500 IF(NN.EQ.0)NN=1
23600 IF(NN.LT.0)GO TO 5061
23700 IF(NN.LE.N)NN=N+1
23800 C FOR USE WITH AUTO-BEAMS OR DIP UP. 2-NOTE SLUR OR BEAM UP.
23900
24000 5061 MK=N
24100 C*** 4/80 N=NN
24200 C***CC N=IABS(NN)
24300 N=IABS(NN)
24400 M=K
24500 JA=3
24600 JB=4
24700 KN=K
24800 RB=0
24900 GO TO 550
25000 504 RB=2
25100 IF(NN.LT.0)RB=-RB
25200 C STEM DIRECT. IS SET BY PARAM 7. (STEM DIR. IS AUTOMATIC)
25300 550 RN(JA+IS)=POS
25400 CX B=XNOTE(K)
25500 B=ZNOTE(K)
25600 C ZNOTE GETS HEIGHT AND CHECKS FOR NOTE ON OTHER STAFF/STEM DIR.
25700
25800 513 RN(JB+IS)=B+RB
25900 C MK=# OF 1ST NOTE, N=END NOTE NOW
26000 JMP=-JMP
26100 IF(JMP.GT.0)GO TO 1503
26200 C GO FIND RT. SIDE OF SLUR
26300 JA=6
26400 JB=5
26500 IF(N.LE.MK)N=MK+1
26600 C PICKS UP TYPO ERRORS
26700 GO TO 503
26800
26900 1503 RN(2+IS)=STAFF
27000 IF(NN.GE.0)GO TO 277
27100 IF(C.GT.0)GO TO 377
27200 277 IF(C.GE.0)GO TO 35
27300 IF(NN.LE.0)GO TO 35
27400 377 NN=-NN
27500
27600 CCCC35 RA=10.
27700 C RA WILL=# OF TAILS, KN=1ST NOTE, K=LAST ('MOD' FOR DOTTED NOTES.)
27800 35 RN(1+IS)=6
27900 JMAX=0
28000 IF(N-MK.EQ.1)JMAX=-1
28100 DMAX=100.
28200 UMAX=-DMAX
28300 C FOR AUTO. BEAMS
28400
28500 JB=0
28600 MB=0
28700 C MB=-1 =GRACE NOTES UNDER BEAMS.
28800 IF(ABS(R(4,KN)).GE.80.)MB=-1
28900 RDIF=0
29000 C JDIF AND RDIF ARE FOR NEW COMPOSITE BEAM FEATURE 5/78
29100 JDIF=0
29200 DO 2 L=KN,K
29300 IF(R(1,L).NE.1)GO TO 2
29400 IF(JDIF.NE.0)GO TO 1212
29500 BB=RHY(L)
29600 IF(BB.LE.0)GO TO 1212
29700 IF(BB.EQ.4./88.)GO TO 1212
29800 IF(RDIF.NE.0)GO TO 2212
29900 RDIF=BB
30000 C NOW WE HAVE FIRST RHYTH. VALUE UNDER BEAM
30100 RA=AMOD(R(7,L),10.0)
30200 C RA WILL=# OF TAILS ON 1ST NOTE.
30300 GO TO 1212
30400 2212 IF(RDIF.EQ.BB)GO TO 1212
30500 JDIF=L
30600 KDIF=IS
30700 C FOUND A DIFF. RHYTH. UNDER BEAM
30800 CXCX1212 IF(R(10,L).NE.0)GO TO 2
30900 C SKIP NOTES ON ANOTHER STAFF.**************?????????????
31000 1212 BB=R(5,L)
31100 IF(BB.GE.10.)GO TO 12
31200 UPDN=-1
31300 NN=19-AA
31400 CHORDS WILL HAVE FIXED STEM DIRECTIONS ALWAYS
31500 GO TO 2
31600 C SKIPS NON-NOTES AND DBLSTPS
31700 12 IF(MB.LT.0)GO TO 10
31800 AA=BB
31900 RB=R(4,L)
32000 IF(ABS(RB).GE.80)GO TO 2
32100 C SKIPS GRACE NOTES
32200 GO TO 110
32300 10 RB=ZNOTE(L)
32400 CX10 RB=XNOTE(L)
32500 110 IF(RB.GT.UMAX)UMAX=RB
32600 IF(RB.LT.DMAX)DMAX=RB
32700 C FOR AUTO. BEAMS
32800 RB=AMOD(R(7,L),10.0)
32900 112 IF(RA.EQ.RB)GO TO 2
33000 JB=-1
33100 C FLAG FOR MIXED NUM. OF BEAMS
33200 IF(RB.GE.RA)GO TO 2
33300 IF(RB.NE.0)RA=RB
33400 2 CONTINUE
33500 C ABOVE FINDS SMALLEST # OF TAILS. NEXT FOR HGTS.
33600 C ABOVE IS POS.2
33700 IT=KN
33800 M=3
33900 203 IF(R(10,IT).EQ.0)GO TO 202
34000 IF(JSTEM.GT.IT)GO TO 202
34100 CS IF(STEM.LE.0)GO TO 202
34200 C=RNW
34300 IF(NN.LT.0)GO TO 206
34400 IF(R(5,IT).LT.20)GO TO 202
34500 C=-C
34600 GO TO 205
34700 206 IF(R(5,IT).GE.20)GO TO 202
34800 205 IF(ABS(R(4,IT)).GE.80.)C=C*.6
34900 C FOR MINI BEAMS
35000 RN(M+IS)=RN(M+IS)+C*RSTJ2
35100 202 IF(IT.NE.KN)GO TO 201
35200 IT=K
35300 M=6
35400 GO TO 203
35500
35600 C FOR EXTRA BEAMS WITH CHORDS. SAVE IT IN "IT"
35700 201 IF(JSTEM.LE.IT)GO TO 577
35800 CS201 IF(STEM.GT.0)GO TO 577
35900 C *****↑↑↑↑↑↑ ABOVE WAS ".NE." BEFORE 4/30/76. WHY?#@&Xαε
36000 C*** IF(UPDN.NE.0)GO TO 577
36100 IF(UPDN.EQ.-1)GO TO 577
36200 NN=-1
36300 IF(UMAX+DMAX.LT.14)NN=-NN
36400 C SETS AUTO. BEAMS' STEM DIRECTION.
36500 IF(UPDN.NE.0)NN=UPDN
36600 577 X=10
36700 IF(NN.LT.0)X=20
36800 IF(MB.LT.0)RA=2
36900 C 2 BEAMS ON GRACE NOTES ALWAYS
37000 X=X+RA
37100 C # OF BEAMS. IT'S PUT IN DOWN BELOW 550.
37200 200 M=KN
37300 207 L=M+1
37400 IF(R(1,L).NE.1)GO TO 307
37500 IF(R(5,L).GE.10)GO TO 307
37600 M=M+1
37700 GO TO 207
37800 C FOR HEIGHTS OF DBL STPS, ETC.
37900 307 CONTINUE
38000 CX607 A=XNOTE(M)
38100 607 A=ZNOTE(M)
38200 C A=NOTE 1.
38300 UMAX=A
38400 DMAX=A
38500 C UP MAX. NOTE #, DOWN MAX. NOTE #.
38600 407 M=K+1
38700 IF(R(1,M).NE.1)GO TO 603
38800 CC IF(R(9,M).NE.0)GO TO 603
38900 IF(R(5,M).GE.10)GO TO 603
39000 C FINDS DBL+ STP ON LAST OF BEAM
39100 IF(R(6,M))GO TO 603
39200 C JUMP OUT IF A WHITE NOTE
39300 K=M
39400 GO TO 407
39500 CXX 103 IF(JSTEM.GT.KN)GO TO 604
39600 C FLAG IS SET (NR) IF STEMS ARE SPECIFIED IN DIFF. DIRECTIONS. (GRACE NTS??)
39700 CXX 604 NR=0
39800
39900 603 DO 3 M=KN,K
40000 IF(R(1,M).NE.1)GO TO 3
40100 CXCXCX IF(STEM.NE.0.AND.R(10,M).NE.0)GO TO 3
40200 C SKIP NOTES ON OTHER STAFF
40300 IF(M.EQ.K)GO TO 107
40400 IF(R(1,M+1).NE.1)GO TO 107
40500 C IT ONLY CARES ABOUT NOTES!
40600 IF(R(5,M+1).LT.10)GO TO 3
40700 C IGNORE LOWER (OR UPPER) NOTES OF CHORDS (NO STEM)-IN RE. UP-DOWN FEATURE.
40800 107 IF(MB.LT.0)GO TO 7
40900 C SKIP IF DEALING WITH GRACE NOTE BEAMS. (MB=-1)
41000 IF(ABS(R(4,M)).GE.100)GO TO 3
41100 C SKIPS NON-NOTES
41200 CX7 B=XNOTE(M)
41300 7 B=ZNOTE(M)
41400 677 IF(JSTEM.LE.KN)GO TO 55
41500 C IGNORE STEM DIR. IF ALREADY SPECIFIED WITHIN THIS GROUP
41600 AA=R(5,M)
41700 CXX IF(AA.LT.10.)GO TO 3
41800 IF(AA.LT.10.)GO TO 551
41900 STMDR=AA
42000 CZZ IF(AA.GE.10.)STMDR=AA
42100 IF(NN.GT.0)GO TO 5
42200 C JUMP IF STEM UP
42300 IF(STMDR.GE.20.)GO TO 55
42400 IF(STMDR.LT.10.)GO TO 55
42500 R(5,M)=STMDR+10.
42600 GO TO 551
42700 5 IF(STMDR.LT.20.)GO TO 55
42800 R(5,M)=STMDR-10.
42900 C************************
43000 C STEM UP
43100 551 INVT=0
43200 55 IF(B.LT.UMAX)GO TO 13
43300 CC55 IF(B.LE.UMAX)GO TO 13
43400 C ↑↑↑↑↑↑↑↑ WAS .LT. !!!!! 5/76
43500 UMAX=B
43600 IF(JMAX.LT.0)GO TO 3
43700 IF(M.EQ.KN)GO TO 3
43800 IF(M.EQ.K)GO TO 3
43900 UMAX=UMAX+1
44000 GO TO 3
44100 13 IF(B.GT.DMAX)GO TO 3
44200 DMAX=B
44300 IF(JMAX.LT.0)GO TO 3
44400 IF(M.EQ.KN)GO TO 3
44500 IF(M.NE.K)DMAX=DMAX-1
44600 3 CONTINUE
44700 C LOOKS FOR LOWER AND HIGHER NOTES THAN NOTE 1.
44800 C*************************************
44900
45000 4 K=IT
45100 C FOR EXTRA BEAMS WITH CHORDS. K WAS SAVED IN "IT"
45200 AA=A
45300 BB=B
45400 C=1
45500 IF(X.LT.20.)GO TO 48
45600 C JUMP IF STEM IS UP
45700 CALL EXCH(AA,BB)
45800 C=-C
45900 CALL EXCH(UMAX,DMAX)
46000 48 IF(AA.LT.BB)GO TO 45
46100 IF(UMAX.EQ.A)GO TO 46
46200 47 A=UMAX-C
46300 B=A
46400 GO TO 444
46500 46 IF(UMAX.GT.AA)GO TO 47
46600 GO TO 49
46700 45 IF(UMAX.NE.B)GO TO 47
46800 49 A=AA
46900 B=BB
47000 IF(X.GE.20)CALL EXCH(A,B)
47100
47200 444 RN(2+IS)=STAFF
47300 446 DIS=(RN(IS+6)-RN(IS+3))/6.
47400 C FOR TILT LATER --
47500 IF(ABS(A-B).LT.DIS)GO TO 143
47600 C=C*DIS
47700 C NEW TILT ROUTINE. CONSIDERS DISTANCE:HEIGHT
47800 C LIMITS SLOPE OF BEAM
47900 IF(X.GE.20)GO TO 141
48000 IF(B.GT.A)GO TO 140
48100 142 B=A-C
48200 GO TO 143
48300 141 IF(B.GT.A)GO TO 142
48400 140 A=B-C
48500
48600 143 JA=KN+1
48700 IF(R(1,JA).NE.1.OR.R(5,JA).GE.10)GO TO 144
48800 M=K+1
48900 IF(R(1,M).NE.1.OR.R(5,M).GE.10)GO TO 144
49000 IF(R(4,JA).EQ.R(4,M).AND.R(4,KN).EQ.R(4,K))B=A
49100 C MAKE BEAM LEVEL IF SAME DYAD AT START AND END.
49200 144 IF(X.GE.20)GO TO 530
49300 C BEAM WILL ALWAYS TOUCH MIDDLE LINE OF STAFF
49400 IF(A.LT.0)A=0
49500 IF(B.LT.0)B=0
49600 GO TO 14
49700 530 IF(A.GT.14)A=14
49800 IF(B.GT.14)B=14
49900 C GETS NEW HEIGHT NUMBERS.
50000
50100 14 IF(MB.EQ.0)GO TO 330
50200 C NEXT FOR GRACE NOTE BEAMS (MB=-1)
50300 C=100
50400 IF(A.LT.0)C=-C
50500 A=A+C
50600 330 C=AMOD(X,10.0)-2
50700 IF(C.LE.0)GO TO 331
50800 C NEXT PUSHES OUT BEAMS IF 3 OR MORE.
50900 C=C+1
51000 IF(NN.LT.0)C=-C
51100 A=A+C
51200 B=B+C
51300 331 RN(4+IS)=A
51400 RN(5+IS)=B
51500 C MAKES HORIZONTAL BEAMS IF PATTERN IS UP-DOWN.
51600 C*******?????? RN(6+IS)=R(3,K)
51700 C ABOVE IS POS.2
51800 C NEXT TO FIND TREMOLOS WHICH SHOULD BE PARALLEL TO BEAM.
51900 JA=IX
52000 AA=RN(IS+3)
52100 BB=RN(IS+6)
52200 300 IF(JA.GE.LS)GO TO 510
52300 C LS IS PTR TO RN ARRAY BEFORE BEAMS WERE ADDED.
52400 IF(RN(JA+1).EQ.6)GO TO 1300
52500 2300 JA=RN(JA)+JA+3
52600 C PUSH PTR AHEAD
52700 GO TO 300
52800 1300 C=RN(JA+3)
52900 IF(C.LT.AA.OR.C.GT.BB)GOTO 2300
53000 C NOW WE'VE FOUND TREM. WITHIN RANGE OF CURRENT BEAM.
53100 RN(JA+9)=C
53200 RN(JA+3)=AA
53300 RN(JA+6)=BB
53400 RN(JA+4)=A
53500 RN(JA+5)=B
53600 C=RN(JA+7)
53700 IF(C.GT.-20.)GO TO 3300
53800 IF(X.LT.20.)C=C+10
53900 GO TO 4300
54000 3300 IF(X.GE.20)C=C-10
54100 4300 RN(JA+7)=C
54200 C X=P7 INFO FOR CURRENT BEAM. (STEM DIR., NUM. OF BEAMS.)
54300 RN(JA+10)=ABS(AMOD(X,10.0))
54400 GO TO 2300
54500
54600 C ***********KN = 1ST NOTE, K=LAST NOTE.********
54700 510 M=R(5,KN)/10.0
54800 RN(7+IS)=M*10+AMOD(X,10.0)
54900 RN(10+IS)=0
55000 RN(IS+11)=-1
55100 CALL UPDATE(9)
55200 JA=IS
55300 C************************************** BMX ***********
55400 IF(JB.LT.0)CALL BMX(RA)
55500 IF(JA.NE.IS)GO TO 514
55600 IF(JDIF.EQ.0)GO TO 514
55700 C FOR NEW COMPOSITE BEAM FEATURE 4/78
55800 IF(RA.EQ.1)GO TO 514
55900 RN(7+KDIF)=X-1
56000 RN(10+KDIF)=100
56100 DO 515 K=JDIF-1,1,-1
56200 C LOOK FOR INTERVENING GRACE NOTES OR RESTS.
56300 N=K
56400 IF(R(1,K).NE.1)GO TO 515
56500 IF(R(8,K).EQ.1000.)GO TO 515
56600 N=K
56700 GO TO 516
56800 515 CONTINUE
56900 516 RN(8+KDIF)=R(3,N)
57000 RN(9+KDIF)=R(3,JDIF)
57100 A=R(3,N)
57200 B=R(3,JDIF)
57300 IF(A.EQ.RN(3+KDIF))A=A+2.4
57400 IF(B.EQ.RN(6+KDIF))B=B-2.4
57500 CREATES PARTIAL BEAM IF NECESSARY. (I.E. THERE'S A REST INVOLVED.)
57600 RN(8+KDIF)=A
57700 RN(9+KDIF)=B
57800
57900 514 J=J+1
58000 A=VX(J)
58100 N=A
58200 C SO ITEMS NEED NOT BE IN RIGHT ORDER.
58300 IF(MOD(N,100).GT.IRHY)A=0
58400 IF(A.NE.0)GO TO 505
58500 IF(J.LT.50)GO TO 514
58600 C SOMETIMES A SLASH IS SEEN AS A 0 (WHEN PRECEDED BY SPACE).
58700 614 IF(INP(72).NE.ISTAR)GO TO 552
58800
58900 714 IF(INVT)RETURN
59000 INVT=IS
59100 CALL NEWR
59200 IS=INVT
59300 RETURN
59400 552 CALL BMREAD
59500 C TO READ MORE THAN 2 LINES.
59600 GO TO 25
59700 END
59800
59900 SUBROUTINE BMREAD
60000 COMMON /ALF/INP(72) /IDEV/IDEV
60100 CALL TYPE
60200 C12/80 IF(IDEV.EQ.5)WRITE(21,4501)INP
60250 IF(IDEV.EQ.5)CALL INPOUT
60275 C WRITES OUT INPUT LINE.
60300 1 CALL LNEND
60400 CALL LULOOP
60500 C CHANGE LOWER CASE TO UPPER.
60600 C12/80 4501 FORMAT(72A1)
60700 END
60800